home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / data_base.t < prev    next >
Text File  |  1988-02-05  |  2KB  |  53 lines
  1. (herald properties (env tsys))
  2.  
  3. ;;; Property lists implimented with tables.
  4.  
  5. (import t-implementation-env make-freelist
  6.                              cons-from-this-freelist
  7.                              return-to-this-freelist)
  8.  
  9.  
  10. (define (property? obj)
  11.   (and (pair? obj)
  12.        (symbol? (car obj))
  13.        (symbol? (cdr obj))))
  14.  
  15. (define (compare-property? key bucket)
  16.   (and (eq? (car key) (car bucket))
  17.        (eq? (cdr key) (cdr bucket))))
  18.  
  19. (define (property-hash key)
  20.   (fx-xor (symbol-hash (car key)) (fx-ashl (symbol-hash (cdr key)) 8)))
  21.  
  22. (define property-freelist (make-freelist))
  23.  
  24. (define property-table
  25.   (make-hash-table property? property-hash compare-property? nil 'property-table))
  26.  
  27. (define property
  28.   (object (lambda (symbol property)
  29.             (let* ((symbol   (enforce symbol? symbol))
  30.                    (property (enforce symbol? property))
  31.                    (key (cons-from-this-freelist property-freelist symbol property))
  32.                    (val (table-entry property-table key)))
  33.               (return-to-this-freelist property-freelist key)
  34.               val))
  35.           ((setter self) set-property)))
  36.  
  37. (define (set-property symbol property value)
  38.   (let* ((symbol   (enforce symbol? symbol))
  39.          (property (enforce symbol? property))
  40.          (key      (cons-from-this-freelist property-freelist symbol property)))
  41.     (set (table-entry property-table key) value)
  42.     (return-to-this-freelist property-freelist key)
  43.     (return)))
  44.  
  45. ;;; Redundant cruft
  46.  
  47. (define-integrable (remove-property symbol property)
  48.   (set (property symbol property) nil)
  49.   (return))
  50.  
  51. (define-integrable get property)
  52. (define-integrable put set-property)
  53.